Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/ftpser1a/ftp_srv.frm

Visual Basic Form | 1999-10-04 | 13.0 KB | 370 lines

VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form FtpServ
   Appearance      =   0  'Flat
   AutoRedraw      =   -1  'True
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "FTP SERVER"
   ClientHeight    =   4575
   ClientLeft      =   1455
   ClientTop       =   3105
   ClientWidth     =   8355
   BeginProperty Font
      Name            =   "MS Sans Serif"
      Size            =   8.25
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Icon            =   "FTP_SRV.frx":0000
   LinkTopic       =   "FtpServ"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4575
   ScaleWidth      =   8355
   StartUpPosition =   2  'CenterScreen
   Begin VB.TextBox UsrCnt
      Height          =   285
      Left            =   3240
      TabIndex        =   5
      Text            =   "0"
      Top             =   3960
      Width           =   855
   End
   Begin VB.CommandButton EndCmd
      Caption         =   "Close Connection"
      Height          =   375
      Left            =   120
      TabIndex        =   3
      Top             =   3840
      Width           =   1935
   End
   Begin VB.Frame StatFrame
      Caption         =   "Status Window"
      Height          =   3735
      Left            =   120
      TabIndex        =   1
      Top             =   0
      Width           =   8055
      Begin VB.ListBox LogWnd
         Appearance      =   0  'Flat
         BackColor       =   &H00000000&
         BeginProperty Font
            Name            =   "MS Serif"
            Size            =   6.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H0000FF00&
         Height          =   3165
         ItemData        =   "FTP_SRV.frx":030A
         Left            =   120
         List            =   "FTP_SRV.frx":030C
         TabIndex        =   2
         Top             =   240
         Width           =   7815
      End
   End
   Begin ComctlLib.StatusBar StatusBar
      Align           =   2  'Align Bottom
      Height          =   255
      Left            =   0
      TabIndex        =   0
      Top             =   4320
      Width           =   8355
      _ExtentX        =   14737
      _ExtentY        =   450
      SimpleText      =   ""
      _Version        =   327682
      BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7}
         NumPanels       =   3
         BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7}
            Object.Width           =   10654
            MinWidth        =   10654
            Object.Tag             =   ""
         EndProperty
         BeginProperty Panel2 {0713E89F-850A-101B-AFC0-4210102A8DA7}
            Style           =   6
            Object.Width           =   2187
            MinWidth        =   2187
            TextSave        =   "10/05/1999"
            Object.Tag             =   ""
         EndProperty
         BeginProperty Panel3 {0713E89F-850A-101B-AFC0-4210102A8DA7}
            Style           =   5
            Object.Width           =   1764
            MinWidth        =   1764
            TextSave        =   "1:55 AM"
            Object.Tag             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.Timer Timer1
      Enabled         =   0   'False
      Index           =   4
      Interval        =   50
      Left            =   7200
      Top             =   3840
   End
   Begin VB.Timer Timer1
      Enabled         =   0   'False
      Index           =   3
      Interval        =   50
      Left            =   6720
      Top             =   3840
   End
   Begin VB.Timer Timer1
      Enabled         =   0   'False
      Index           =   2
      Interval        =   50
      Left            =   6240
      Top             =   3840
   End
   Begin VB.Timer Timer1
      Enabled         =   0   'False
      Index           =   1
      Interval        =   50
      Left            =   5760
      Top             =   3840
   End
   Begin VB.Timer Timer1
      Enabled         =   0   'False
      Index           =   0
      Interval        =   50
      Left            =   5280
      Top             =   3840
   End
   Begin VB.Label Label1
      Caption         =   "# of Users"
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   2280
      TabIndex        =   4
      Top             =   3960
      Width           =   975
   End
   Begin VB.Menu mSetup
      Caption         =   "Setup"
   End
Attribute VB_Name = "FtpServ"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub EndCmd_Click()
Dim i As Integer
  For i = 1 To MAX_N_USERS    'close all connection
    If users(i).control_slot <> INVALID_SOCKET Then
      retf = closesocket(users(i).control_slot) 'close control slot
    End If
    If users(i).data_slot <> INVALID_SOCKET Then
      retf = closesocket(users(i).data_slot) 'close data slot
    End If
  Next
  retf = closesocket(ServerSlot)
  If SaveProfile(App.Path & "\ftp_srv.ini", True) Then
  End If
  Unload Me
End Sub
Private Sub Form_Load()
Dim i As Integer
Dim hdr As String, item As String
  '--- Initialization
  'an FTP command is terminated by Carriage_Return & Line_Feed
  'possible sintax errors in FTP commands
  sintax_error_list(0) = "200 Command Ok."
  sintax_error_list(1) = "202 Command not implemented, superfluous at this site."
  sintax_error_list(2) = "500 Sintax error, command unrecognized."
  sintax_error_list(3) = "501 Sintax error in parameters or arguments."
  sintax_error_list(4) = "502 Command not implemented."
  sintax_error_list(6) = "504 Command not implemented for that parameter."
  'initializes the list which contains the names,
  'passwords, access rights and default directory
  'recognized by the server
  If LoadProfile(App.Path & "\ftp_srv.ini") Then
    '
  Else
    StatusBar.Panels(1) = "Error Loading Ini File!"
  End If
  'initializes the records which contain the
  'informations on the connected users
  For i = 1 To MAX_N_USERS
    users(i).list_index = 0
    users(i).control_slot = INVALID_SLOT
    users(i).data_slot = INVALID_SLOT
    users(i).IP_address = ""
    users(i).Port = 0
    users(i).data_representation = "A"
    users(i).data_format_ctrls = "N"
    users(i).data_structure = "F"
    users(i).data_tx_mode = "S"
    users(i).cur_dir = ""
    users(i).state = 0
    users(i).full = False
  Next
  OldWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
  vbWSAStartup
  'begins SERVER mode on port 21
  ServerSlot = ListenForConnect(21, hWnd)
  If ServerSlot > 0 Then
    StatusBar.Panels(1) = Description
  Else
    StatusBar.Panels(1) = "Error Creating Listening Socket"
  End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
  SetWindowLong hWnd, GWL_WNDPROC, OldWndProc
  vbWSACleanup
End Sub
Private Sub mSetup_Click()
  UserOpts.Show 1
End Sub
Private Sub Timer1_Timer(index As Integer)
Dim close_data_cnt As Integer
Dim error_on_data_cnt As Integer
Select Case files_info(index).retr_stor
  Case 0:  '--- R E T R  Command
  If files_info(index).data_representation = "A" Then
    If Not files_info(index).open_file Then
      Open files_info(index).Full_Name For Input Lock Write As #index 'open file
      files_info(index).open_file = True
    End If
    'sends the file on data connection; data are sent a line at a time
    If files_info(index).try_again Then
    Else      're-send old line
      Line Input #index, files_info(index).Buffer
    End If
    retf = send_data(files_info(index).Buffer & vbCrLf, index)
    If retf < 0 Then 'SOCKET_ERROR
      retf = WSAGetLastError()
      If retf = WSAEWOULDBLOCK Then
        files_info(index).try_again = True
      Else        'error on sending
        error_on_data_cnt = True
        close_data_cnt = True
      End If
    Else
      files_info(index).try_again = False
    End If
    If EOF(index) Then close_data_cnt = True
  Else  'binary transfer
    If Not files_info(index).open_file Then
      Open files_info(index).Full_Name For Binary Lock Write As #index
      files_info(index).open_file = True
    End If
    'sends file on data connection; data are sent in blocks of 1024 bytes
    If files_info(index).next_block = 0 Then
      files_info(index).File_Len = LOF(index)
      files_info(index).blocks = Int(files_info(index).File_Len / 1024)    '# of blocks
      files_info(index).spare_bytes = files_info(index).File_Len Mod 1024  '# of remaining bytes
      files_info(index).Buffer = String$(1024, " ")
    End If
    If files_info(index).next_block < files_info(index).blocks Then 'sends blocks
      Get #index, files_info(index).next_byte + 1, files_info(index).Buffer
      retf = send_data(files_info(index).Buffer, index)
      If retf < 0 Then
        retf = WSAGetLastError()
        If retf = WSAEWOULDBLOCK Then  'try again
        Else
          error_on_data_cnt = True
          close_data_cnt = True
        End If
      Else   'next block
        files_info(index).next_block = files_info(index).next_block + 1
        files_info(index).next_byte = files_info(index).next_byte + 1024
      End If
    Else    'sends remaining bytes
      files_info(index).Buffer = String$(files_info(index).spare_bytes, " ")
      Get #index, , files_info(index).Buffer
      retf = send_data(files_info(index).Buffer, index)
      close_data_cnt = True
    End If
  End If
  If close_data_cnt Then  're-initialize files_info record
    files_info(index).open_file = False
    files_info(index).next_block = 0  'blocks count
    files_info(index).next_byte = 0   'pointer to next block
    files_info(index).try_again = False
    Close #index    'close file
    If error_on_data_cnt Then    'replies to user
      retf = send_reply("550 RETR command not executed.", index)
    Else
      retf = send_reply("226 RETR command completed.", index)
    End If
    retf = close_data_connect(index)    'close data connection
    Timer1(index).Enabled = False    'disables timer
  End If
  Case 1:  '--- S T O R  Command
  If files_info(index).data_representation = "A" Then
    If Not files_info(index).open_file Then    'open file
      Open files_info(index).Full_Name For Output Lock Read Write As #index
      files_info(index).open_file = True
    End If
    'receives file on data connection;  data are received a line at a time
    retf = receive_data(files_info(index).Buffer, index)
    If retf < 0 Then   'SOCKET_ERROR
      retf = WSAGetLastError()
      If retf = WSAEWOULDBLOCK Then   'try_again
      Else       'error on receiving
        error_on_data_cnt = True
        close_data_cnt = True
      End If
    ElseIf retf = 0 Then  'connection closed by peer
      close_data_cnt = True
    Else 'retf > 0  write on file
      Dummy$ = Left$(files_info(index).Buffer, retf)
      Print #index, Dummy$
    End If
  Else  'binary transfer
    If Not files_info(index).open_file Then   'open file
      Open files_info(index).Full_Name For Binary Lock Read Write As #index
      files_info(index).open_file = True
    End If    'receives file on data connection;
    retf = receive_data(files_info(index).Buffer, index)
    If retf < 0 Then
      retf = WSAGetLastError()
      If retf = WSAEWOULDBLOCK Then  'try again
      Else
        error_on_data_cnt = True
        close_data_cnt = True
      End If
    ElseIf retf = 0 Then     'connection closed by peer
      close_data_cnt = True
    Else
      Dummy$ = Left$(files_info(index).Buffer, retf)
      Put #index, , Dummy$
    End If
  End If
  If close_data_cnt Then   're-initialize files_info record
    files_info(index).open_file = False
    files_info(index).next_block = 0 'blocks count
    files_info(index).next_byte = 0  'pointer to next block
    files_info(index).try_again = False
    Close #index    'close file
    If error_on_data_cnt Then    'replies to user
      retf = send_reply("550 STOR command not executed.", index)
    Else
      retf = send_reply("226 STOR command completed.", index)
    End If
    retf = close_data_connect(index)     'closes data connection
    Timer1(index).Enabled = False    'disables timer
  End If
End Select
End Sub